home *** CD-ROM | disk | FTP | other *** search
/ isnet Internet / Isnet Internet CD.iso / prog / hiz / 09 / 09.exe / adynware.exe / perl / lib / site / Devel / Symdump.pm < prev   
Encoding:
Perl POD Document  |  1999-12-28  |  11.7 KB  |  438 lines
  1. package Devel::Symdump;
  2.  
  3. BEGIN {require 5.003;}
  4. use Carp ();
  5. use strict;
  6. use vars qw($Defaults $VERSION *ENTRY);
  7.  
  8. $VERSION = '2.00';
  9.  
  10. $Defaults = {
  11.          'RECURS'   => 0,
  12.          'AUTOLOAD' => {
  13.                 'packages'    => 1,
  14.                 'scalars'    => 1,
  15.                 'arrays'    => 1,
  16.                 'hashes'    => 1,
  17.                 'functions'    => 1,
  18.                 'ios'    => 1,
  19.                 'unknowns'    => 1,
  20.                }
  21.         };
  22.  
  23. sub rnew {
  24.     my($class,@packages) = @_;
  25.     no strict "refs";
  26.     my $self = bless {%${"$class\::Defaults"}}, $class;
  27.     $self->{RECURS}++;
  28.     $self->_doit(@packages);
  29. }
  30.  
  31. sub new {
  32.     my($class,@packages) = @_;
  33.     no strict "refs";
  34.     my $self = bless {%${"$class\::Defaults"}}, $class;
  35.     $self->_doit(@packages);
  36. }
  37.  
  38. sub _doit {
  39.     my($self,@packages) = @_;
  40.     @packages = ("main") unless @packages;
  41.     $self->{RESULT} = $self->_symdump(@packages);
  42.     return $self;
  43. }
  44.  
  45. sub _symdump {
  46.     my($self,@packages) = @_ ;
  47.     my($key,$val,$num,$pack,@todo,$tmp);
  48.     my $result = {};
  49.     foreach $pack (@packages){
  50.     no strict;
  51.     while (($key,$val) = each(%{*{"$pack\::"}})) {
  52.         my $gotone = 0;
  53.         local(*ENTRY) = $val;
  54.         if (defined $val && defined *ENTRY{SCALAR}) {
  55.         $result->{$pack}{SCALARS}{$key}++;
  56.         $gotone++;
  57.         }
  58.         if (defined $val && defined *ENTRY{ARRAY}) {
  59.         $result->{$pack}{ARRAYS}{$key}++;
  60.         $gotone++;
  61.         }
  62.         if (defined $val && defined *ENTRY{HASH} && $key !~ /::/) {
  63.         $result->{$pack}{HASHES}{$key}++;
  64.         $gotone++;
  65.         }
  66.         if (defined $val && defined *ENTRY{HASH} && $key =~ /::$/ &&
  67.             $key ne "main::")
  68.         {
  69.         my($p) = $pack ne "main" ? "$pack\::" : "";
  70.         ($p .= $key) =~ s/::$//;
  71.         $result->{$pack}{PACKAGES}{$p}++;
  72.         $gotone++;
  73.         push @todo, $p;
  74.         }
  75.         if (defined $val && defined *ENTRY{CODE}) {
  76.         $result->{$pack}{FUNCTIONS}{$key}++;
  77.         $gotone++;
  78.         }
  79.  
  80.         if ($] > 5.003_10){
  81.         if (defined $val && defined *ENTRY{IO}){ # fileno and telldir...
  82.             $result->{$pack}{IOS}{$key}++;
  83.             $gotone++;
  84.         }
  85.         } else {
  86.         if (defined fileno(ENTRY)){
  87.             $result->{$pack}{IOS}{$key}++;
  88.             $gotone++;
  89.         } elsif (defined telldir(ENTRY)){
  90.             $result->{$pack}{IOS}{$key}++;
  91.             $gotone++;
  92.         }
  93.         }
  94.  
  95.         unless ($gotone) {
  96.         $result->{$pack}{UNKNOWNS}{$key}++;
  97.         }
  98.     }
  99.     }
  100.  
  101.     return (@todo && $self->{RECURS})
  102.         ? { %$result, %{$self->_symdump(@todo)} }
  103.         : $result;
  104. }
  105.  
  106. sub _partdump {
  107.     my($self,$part)=@_;
  108.     my ($pack, @result);
  109.     my $prepend = "";
  110.     foreach $pack (keys %{$self->{RESULT}}){
  111.     $prepend = "$pack\::" unless $part eq 'PACKAGES';
  112.     push @result, map {"$prepend$_"} keys %{$self->{RESULT}{$pack}{$part} || {}};
  113.     }
  114.     return @result;
  115. }
  116.  
  117. sub DESTROY {}
  118.  
  119. sub as_string {
  120.     my $self = shift;
  121.     my($type,@m);
  122.     for $type (sort keys %{$self->{'AUTOLOAD'}}) {
  123.     push @m, $type;
  124.     push @m, "\t" . join "\n\t", map {
  125.         s/([\000-\037\177])/ '^' . pack('c', ord($1) ^ 64) /eg;
  126.         $_;
  127.     } sort $self->_partdump(uc $type);
  128.     }
  129.     return join "\n", @m;
  130. }
  131.  
  132. sub as_HTML {
  133.     my $self = shift;
  134.     my($type,@m);
  135.     push @m, "<TABLE>";
  136.     for $type (sort keys %{$self->{'AUTOLOAD'}}) {
  137.     push @m, "<TR><TD valign=top><B>$type</B></TD>";
  138.     push @m, "<TD>" . join ", ", map {
  139.         s/([\000-\037\177])/ '^' .
  140.         pack('c', ord($1) ^ 64)
  141.             /eg; $_;
  142.     } sort $self->_partdump(uc $type);
  143.     push @m, "</TD></TR>";
  144.     }
  145.     push @m, "</TABLE>";
  146.     return join "\n", @m;
  147. }
  148.  
  149. sub diff {
  150.     my($self,$second) = @_;
  151.     my($type,@m);
  152.     for $type (sort keys %{$self->{'AUTOLOAD'}}) {
  153.     my(%first,%second,%all,$symbol);
  154.     foreach $symbol ($self->_partdump(uc $type)){
  155.         $first{$symbol}++;
  156.         $all{$symbol}++;
  157.     }
  158.     foreach $symbol ($second->_partdump(uc $type)){
  159.         $second{$symbol}++;
  160.         $all{$symbol}++;
  161.     }
  162.     my(@typediff);
  163.     foreach $symbol (sort keys %all){
  164.         next if $first{$symbol} && $second{$symbol};
  165.         push @typediff, "- $symbol" unless $second{$symbol};
  166.         push @typediff, "+ $symbol" unless $first{$symbol};
  167.     }
  168.     foreach (@typediff) {
  169.         s/([\000-\037\177])/ '^' . pack('c', ord($1) ^ 64) /eg;
  170.     }
  171.     push @m, $type, @typediff if @typediff;
  172.     }
  173.     return join "\n", @m;
  174. }
  175.  
  176. sub inh_tree {
  177.     my($self) = @_;
  178.     return $self->{INHTREE} if ref $self && defined $self->{INHTREE};
  179.     my($inherited_by) = {};
  180.     my($m)="";
  181.     my(@isa) = grep /\bISA$/, Devel::Symdump->rnew->arrays;
  182.     my $isa;
  183.     foreach $isa (sort @isa) {
  184.     $isa =~ s/::ISA$//;
  185.     my($isaisa);
  186.     no strict 'refs';
  187.     foreach $isaisa (@{"$isa\::ISA"}){
  188.         $inherited_by->{$isaisa}{$isa}++;
  189.     }
  190.     }
  191.     my $item;
  192.     foreach $item (sort keys %$inherited_by) {
  193.     $m .= "$item\n";
  194.     $m .= _inh_tree($item,$inherited_by);
  195.     }
  196.     $self->{INHTREE} = $m if ref $self;
  197.     $m;
  198. }
  199.  
  200. sub _inh_tree {
  201.     my($package,$href,$depth) = @_;
  202.     return unless defined $href;
  203.     $depth ||= 0;
  204.     $depth++;
  205.     if ($depth > 100){
  206.     warn "Deep recursion in ISA\n";
  207.     return;
  208.     }
  209.     my($m) = "";
  210.     my $i;
  211.     foreach $i (sort keys %{$href->{$package}}) {
  212.     $m .= qq{\t} x $depth;
  213.     $m .= qq{$i\n};
  214.     $m .= _inh_tree($i,$href,$depth);
  215.     }
  216.     $m;
  217. }
  218.  
  219. sub isa_tree{
  220.     my($self) = @_;
  221.     return $self->{ISATREE} if ref $self && defined $self->{ISATREE};
  222.     my(@isa) = grep /\bISA$/, Devel::Symdump->rnew->arrays;
  223.     my($m) = "";
  224.     my($isa);
  225.     foreach $isa (sort @isa) {
  226.     $isa =~ s/::ISA$//;
  227.     $m .= qq{$isa\n};
  228.     $m .= _isa_tree($isa)
  229.     }
  230.     $self->{ISATREE} = $m if ref $self;
  231.     $m;
  232. }
  233.  
  234. sub _isa_tree{
  235.     my($package,$depth) = @_;
  236.     $depth ||= 0;
  237.     $depth++;
  238.     if ($depth > 100){
  239.     warn "Deep recursion in ISA\n";
  240.     return;
  241.     }
  242.     my($m) = "";
  243.     my $isaisa;
  244.     no strict 'refs';
  245.     foreach $isaisa (@{"$package\::ISA"}) {
  246.     $m .= qq{\t} x $depth;
  247.     $m .= qq{$isaisa\n};
  248.     $m .= _isa_tree($isaisa,$depth);
  249.     }
  250.     $m;
  251. }
  252.  
  253. AUTOLOAD {
  254.     my($self,@packages) = @_;
  255.     unless (ref $self) {
  256.     $self = $self->new(@packages);
  257.     }
  258.     no strict "vars";
  259.     (my $auto = $AUTOLOAD) =~ s/.*:://;
  260.  
  261.     $auto =~ s/(file|dir)handles/ios/;
  262.     my $compat = $1;
  263.  
  264.     unless ($self->{'AUTOLOAD'}{$auto}) {
  265.     Carp::croak("invalid Devel::Symdump method: $auto()");
  266.     }
  267.  
  268.     my @syms = $self->_partdump(uc $auto);
  269.     if (defined $compat) {
  270.     no strict 'refs';
  271.     if ($compat eq "file") {
  272.         @syms = grep { defined(fileno($_)) } @syms;
  273.     } else {
  274.         @syms = grep { defined(telldir($_)) } @syms;
  275.     }
  276.     }
  277.     return @syms; # make sure now it gets context right
  278. }
  279.  
  280. 1;
  281.  
  282. __END__
  283.  
  284. =head1 NAME
  285.  
  286. Devel::Symdump - dump symbol names or the symbol table
  287.  
  288. =head1 SYNOPSIS
  289.  
  290.     require Devel::Symdump;
  291.     @packs = qw(some_package another_package);
  292.     $obj = Devel::Symdump->new(@packs);        # no recursion
  293.     $obj = Devel::Symdump->rnew(@packs);       # with recursion
  294.     
  295.     @array = $obj->packages;
  296.     @array = $obj->scalars;
  297.     @array = $obj->arrays;
  298.     @array = $obj->hashs;
  299.     @array = $obj->functions;
  300.     @array = $obj->filehandles;  # deprecated, use ios instead
  301.     @array = $obj->dirhandles;   # deprecated, use ios instead
  302.     @array = $obj->ios;
  303.     @array = $obj->unknowns;
  304.     
  305.     $string = $obj->as_string;
  306.     $string = $obj->as_HTML;
  307.     $string = $obj1->diff($obj2);
  308.  
  309.     $string = Devel::Symdump->isa_tree;    # or $obj->isa_tree
  310.     $string = Devel::Symdump->inh_tree;    # or $obj->inh_tree
  311.  
  312.     @array = Devel::Symdump->packages(@packs);
  313.     @array = Devel::Symdump->scalars(@packs);
  314.     @array = Devel::Symdump->arrays(@packs);
  315.     @array = Devel::Symdump->hashes(@packs);
  316.     @array = Devel::Symdump->functions(@packs);
  317.     @array = Devel::Symdump->ios(@packs);
  318.     @array = Devel::Symdump->unknowns(@packs);
  319.  
  320. =head1 INCOMPATIBILITY ALERT
  321.  
  322. Perl 5.003 already offered the opportunity to test for the individual
  323. slots of a GLOB with the *GLOB{XXX} notation. Devel::Symdump version
  324. 2.00 uses this method internally which means that the type of
  325. undefined values is recognized in general. Previous versions
  326. couldnE<39>t determine the type of undefined values, so the slot
  327. I<unknowns> was invented. From version 2.00 this slot is still present
  328. but will usually not contain any elements.
  329.  
  330. The interface has changed slightly between the perl versions 5.003 and
  331. 5.004. To be precise, from perl5.003_11 the names of the members of a
  332. GLOB have changed. C<IO> is the internal name for all kinds of
  333. input-output handles while C<FILEHANDLE> and C<DIRHANDLE> are
  334. deprecated.
  335.  
  336. C<Devel::Symdump> accordingly introduces the new method ios() which
  337. returns filehandles B<and> directory handles. The old methods
  338. filehandles() and dirhandles() are still supported for a transitional
  339. period.  They will probably have to go in future versions.
  340.  
  341. =head1 DESCRIPTION
  342.  
  343. This little package serves to access the symbol table of perl.
  344.  
  345. =over 4
  346.  
  347. =head2 C<Devel::Symdump-E<gt>rnew(@packages)>
  348.  
  349. returns a symbol table object for all subtrees below @packages.
  350. Nested Modules are analyzed recursively. If no package is given as
  351. argument, it defaults to C<main>. That means to get the whole symbol
  352. table, just do a C<rnew> without arguments.
  353.  
  354. =head2 C<Devel::Symdump-E<gt>new(@packages)>
  355.  
  356. does not go into recursion and only analyzes the packages that are
  357. given as arguments.
  358.  
  359. =back
  360.  
  361. The methods packages(), scalars(), arrays(), hashes(), functions(),
  362. ios(), and unknowns() each return an array of fully qualified
  363. symbols of the specified type in all packages that are held within a
  364. Devel::Symdump object, but without the leading C<$>, C<@> or C<%>.  In
  365. a scalar context, they will return the number of such symbols.
  366. Unknown symbols are usually either formats or variables that havenE<39>t
  367. yet got a defined value.
  368.  
  369. As_string() and as_HTML() return a simple string/HTML representations
  370. of the object.
  371.  
  372. Diff() prints the difference between two Devel::Symdump objects in
  373. human readable form. The format is similar to the one used by the
  374. as_string method.
  375.  
  376. Isa_tree() and inh_tree() both return a simple string representation
  377. of the current inheritance tree. The difference between the two
  378. methods is the direction from which the tree is viewed: top-down or
  379. bottom-up. As IE<39>m sure, many users will have different expectation
  380. about what is top and what is bottom, IE<39>ll provide an example what
  381. happens when the Socket module is loaded:
  382.  
  383. =over 4
  384.  
  385. =item % print Devel::Symdump-E<gt>inh_tree
  386.  
  387.     AutoLoader
  388.             DynaLoader
  389.                     Socket
  390.     DynaLoader
  391.             Socket
  392.     Exporter
  393.             Carp
  394.             Config
  395.             Socket
  396.  
  397. The inh_tree method shows on the left hand side a package name and
  398. indented to the right the packages that use the former.
  399.  
  400. =item % print Devel::Symdump-E<gt>isa_tree
  401.  
  402.     Carp
  403.             Exporter
  404.     Config
  405.             Exporter
  406.     DynaLoader
  407.             AutoLoader
  408.     Socket
  409.             Exporter
  410.             DynaLoader
  411.                     AutoLoader
  412.  
  413. The isa_tree method displays from left to right ISA relationships, so
  414. Socket IS A DynaLoader and DynaLoader IS A AutoLoader. (At least at
  415. the time this manpage was written :-)
  416.  
  417. =back
  418.  
  419. You may call both methods, isa_tree() and inh_tree(), with an
  420. object. If you do that, the object will store the output and retrieve
  421. it when you call the same method again later. The typical usage would
  422. be to use them as class methods directly though.
  423.  
  424. =head1 SUBCLASSING
  425.  
  426. The design of this package is intentionally primitive and allows it to
  427. be subclassed easily. An example of a (maybe) useful subclass is
  428. Devel::Symdump::Export, a package which exports all methods of the
  429. Devel::Symdump package and turns them into functions.
  430.  
  431. =head1 AUTHORS
  432.  
  433. Andreas Koenig F<E<lt>koenig@franz.ww.TU-Berlin.DEE<gt>> and Tom
  434. Christiansen F<E<lt>tchrist@perl.comE<gt>>.  Based on the old
  435. F<dumpvar.pl> by Larry Wall.
  436.  
  437. =cut
  438.